;For compiler, speedup hacks.

(declare (mapex t)
         (special **exp** **env** **unevlis** **evlis** **pc**
			  **clink** **val** **tem** **cenv**
                  **queue** **tick** **quantum** **process** **procnum**
                  version lispversion))

(defun version macro (x)
       (cond (compiler-state (list 'quote (status uread)))
	     (t (rplaca x 'quote)
		(rplacd x (list version))
		(list 'quote version))))

(declare (read))

(setq version ((lambda (compiler-state) (version)) t))

(defun fastcall (atsym)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym))))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr))
			       (t (apply atsym nil))))
		 (get atsym 'subr)))))

(defun fastcall3 (atsym arg1 arg2 arg3)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym)) arg1 arg2 arg3))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr arg1 arg2 arg3))
			       (t (funcall atsym arg1 arg2 arg3))))
		 (get atsym 'subr)))))

;Basic interpreter -- initialization, main-loop, time slicing.

(defun scheme ()
       (setq version (version)  lispversion (status lispversion))
       (terpri)
       (princ '|This is SCHEME |)
       (princ version)
       (princ '| running in LISP |)
       (princ lispversion)
       (setq **env** nil  **cenv** nil  **queue** nil
             **process** (create!process '(**top** '|SCHEME -- Toplevel| '|==> |)))
       (swapinprocess)
       (alarmclock 'runtime **quantum**)
       (mloop))

(setq **top**
      '(lambda (**message** **prompt**)
               (labels ((**top1**
                          (lambda (**ignore1** **ignore2** **ignore3**)
                             (**top1** (terpri) (princ **prompt**)
                                       (print (set '* (evaluate (read))))))))
                    (**top1** (terpri) (princ **message**) nil))))

(defun mloop ()
       (do ((**tick** nil))  (nil)
          (and **tick** (allow) (schedule))
          (fastcall **pc**)))

(defun allow ()
  ((lambda (vcell)
       (cond (vcell (cadr vcell))
             (t t)))
   (assq '*allow* **env**)))

(defun schedule ()
       (cond (**queue**
	      (swapoutprocess)
	      (nconc **queue** (list **process**))
	      (setq **process** (car **queue**)
		    **queue** (cdr **queue**))
	      (swapinprocess)))
       (setq **tick** nil)
       (alarmclock 'runtime **quantum**))

(defun swapoutprocess ()
       ((lambda (**clink**)
                (putprop **process** (saveup **pc**) 'clink)
                (putprop **process** **val** 'val)
		(putprop **process** **cenv** 'cenv))
        **clink**))

(defun swapinprocess () 
       (setq **clink** (get **process** 'clink)
             **val** (get **process** 'val)
	     **cenv** (get **process** 'cenv))
       (restore))

(defun settick (x) (setq **tick** t))
(setq **quantum** 1000000. alarmclock 'settick)

;Central evaluator functions.

(defun dispatch (exp1 env1 retag)
   (prog (tem1)
    lp (cond ((atom exp1)
              (cond ((numberp exp1)
                     (setq **val** exp1  **pc** retag))
                    ((primop exp1)
                     (setq **val** exp1  **pc** retag))
                    ((setq tem1 (assq exp1 env1))
                     (setq **val** (cadr tem1)  **pc** retag))
                    (t (setq **val** (symeval exp1)  **pc** retag))))
             ((eq (car exp1) 'lambda)
              (setq **val** (list 'beta exp1 env1)  **pc** retag))
             ((atom (car exp1))
              (cond ((setq tem1 (get (car exp1) 'aint))
                     (fastcall3 tem1 exp1 env1 retag))
                    ((setq tem1 (get (car exp1) 'amacro))
                     (setq exp1 (funcall tem1 exp1))
                     (go lp))
                    (t (saveup retag)
                       (setq **evlis** (list (cond ((primop (car exp1)) (car exp1))
                                               ((setq tem1 (assq (car exp1) env1))
                                                (cadr tem1))
                                               (t (symeval (car exp1)))))
                             **unevlis** (cdr exp1)
                             **exp** exp1  **env** env1
                             **pc** 'evlis1))))
             ((eq (caar exp1) 'lambda)
              (saveup retag)
              (setq **evlis** (list (car exp1))  **unevlis** (cdr exp1)
                    **exp** exp1  **env** env1
                    **pc** 'evlis1))
             (t (saveup retag)
                (setq **exp** exp1  **env** env1
                      **unevlis** exp1  **evlis** nil
                      **pc** 'evlis1)))))

(defun evlis1 ()
       (cond ((null **unevlis**)
              (prog (ev1 env1)
                    (setq ev1 (reverse **evlis**))
                    (cond ((atom (car ev1))
                           (restore)
                           (setq **val** (apply (car ev1) (cdr ev1))))
                          ((eq (caar ev1) 'lambda)
                           (setq env1 **env**)
                           (restore)
                           (dispatch (caddar ev1)
                                     (pairlis (cadar ev1) (cdr ev1) env1)
                                     **pc**))
                          ((eq (caar ev1) 'beta)
                           (restore)
                           (dispatch (caddr (cadar ev1))
                                     (pairlis (cadr (cadar ev1))
                                              (cdr ev1)
                                              (caddar ev1))
                                     **pc**))
			  ((eq (caar ev1) 'fluid!lambda)
			   (setq **evlis** **cenv**)
			   (setq **cenv**
				 (pairlis (cadar ev1) (cdr ev1) **cenv**))
			   (dispatch (caddar ev1) **env** 'unbind))
                          ((eq (caar ev1) 'delta)
                           (setq **clink** (cadar ev1))
			   (setq **cenv** (caddar ev1))
                           (restore))
                          (t (error '|Bad Function - Evarglist| **exp** 'fail-act)))))
             (t (dispatch (car **unevlis**) **env** 'evlis2))))

(defun evlis2 ()
 (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**)  **pc** 'evlis1))

(defun unbind () (setq **cenv** **evlis**) (restore))

;Basic AINTs.

(defprop evaluate aeval aint)

(defun aeval (exp1 env1 retag)
       (saveup retag) (setq **env** env1)
       (dispatch (cadr exp1) env1 'aeval1))

(defun aeval1 ()
       (setq **tem** **env**) (restore)
       (dispatch **val** **tem** **pc**))

(defprop if aif aint)

(defun aif (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'if1))

(defun if1 ()
   (prog (exp1 env1)
       (setq exp1 **exp**  env1 **env**)
       (restore)
       (cond (**val** (dispatch (caddr exp1) env1 **pc**))
             (t (dispatch (cadddr exp1) env1 **pc**)))))

(defprop test atest aint)

(defun atest (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'test1))

(defun test1 ()
       (cond (**val**
	      (setq **evlis** **val**)
	      (dispatch (caddr **exp**) **env** 'test2))
	     (t ((lambda (exp1 env1)
			 (restore)
			 (dispatch (cadddr exp1) env1 **pc**))
		 **exp** **env**))))

(defun test2 ()
       (setq **evlis** (list **evlis** **val**))
       (setq **unevlis** nil)
       (evlis1))

(defprop quote aquote aint)

(defun aquote (exp1 env1 retag)
       (setq **val** (cadr exp1)  **pc** retag))

(defprop labels alabels aint)

(defun alabels (exp1 env1 retag)
       (setq **tem** (mapcar '(lambda (def)
                                  (list (car def)
                                        (list 'beta (cadr def) nil)))
                         (cadr exp1)))
       (mapc '(lambda (vc) (rplaca (cddadr vc) **tem**)) **tem**)
       (dispatch (caddr exp1) (nconc **tem** env1) retag))

;Side effects.

(defprop define adefine aint)

(defun adefine (exp1 env1 retag)
       (set (cadr exp1) (list 'beta  (caddr exp1) nil))
       (setq **val** (cadr exp1)  **pc** retag))

(defprop aset aaset aint)

(defun aaset (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'aaset1))

(defun aaset1 ()
       (setq **evlis** **val**)
       (dispatch (caddr **exp**) **env** 'aaset2))

(defun aaset2 ()
       (setq **tem** (assq **evlis** **env**))
       (cond (**tem** (rplaca (cdr **tem**) **val**))
             (t (set **evlis** **val**)))
       (restore))

(defprop fluid afluid aint)

(defun afluid (exp1 env1 retag)
       (setq **val**
	     ((lambda (vc)
		      (cond (vc (cadr vc))
			    (t (symeval (cadr exp1)))))
	      (assq (cadr exp1) **cenv**)))
       (setq **pc** retag))

(defprop fluidset afluidset aint)

(defun afluidset (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'fluidset1))

(defun fluidset1 ()
       (setq **evlis** **val**)
       (dispatch (caddr **exp**) **env** 'fluidset2))

(defun fluidset2 ()
       (setq **tem** (assq **evlis** **cenv**))
       (cond (**tem** (rplaca (cdr **tem**) **val**))
             (t (set **evlis** **val**)))
       (restore))


;Hairy control structure.

(setq **procnum** 0)

(defun genprocname ()
       ((lambda (base *nopoint)
		(implode (append '(p r o c e s s)
				  (exploden (setq **procnum** (1+ **procnum**))))))
	10. t))

(defun create!process (exp1)
       ((lambda (**process** **exp** **env** **cenv**
                 **unevlis** **evlis** **pc** **clink** **val**)
                (dispatch exp1 **env** 'terminate)
                (swapoutprocess)
                **process**)
        (genprocname) nil **env** **cenv** nil nil nil nil nil))

(defun start!process (p)
       (cond ((or (not (atom p)) (not (get p 'clink)))
	      (error '|Bad Process - START!PROCESS| p 'fail-act)))
       (or (eq p **process**) (memq p **queue**)
	   (setq **queue** (nconc **queue** (list p))))
       p)

(defun stop!process (p)
       (cond ((memq p **queue**)
	      (setq **queue** (delete p **queue**)))
	     ((eq p **process**) (terminate)))
       p)

(defun terminate ()
       (swapoutprocess)
       (cond ((null **queue**)
	      (setq **env** nil  **cenv** nil)
	      (setq **process**
		    (create!process '(**top** '|SCHEME -- Queueout| '|==> |))))
	     (t (setq **process** (car **queue**)
		      **queue** (cdr **queue**))))
       (swapinprocess)
       'terminate-value)

(defprop evaluate!uninterruptibly evun aint)

(defun evun (exp1 env1 retag)
       (dispatch (cadr exp1) (cons (list '*allow* nil) env1) retag))

(defprop catch acatch aint)

(defun acatch (exp1 env1 retag)
       (dispatch (caddr exp1)
                 (cons (list (cadr exp1)
                             (list 'delta
                                   ((lambda (**clink**) (saveup retag))
                                    **clink**)
                                   **cenv**))
                       env1)
                 retag))

;Interpreter data structures.

(defun pairlis (x y z)
       (do ((i x (cdr i))
            (j y (cdr j))
            (l z (cons (list (car i) (car j)) l)))
           ((and (null i) (null j)) l)
          (and (or (null i) (null j))
               (error '|Wrong Number of Arguments - Pairlis|
		      **exp**
		      'wrng-no-args))))

(defun primop (x) (getl x '(subr expr lsubr)))

(defun saveup (retag)
       (setq **clink** 
             (cons **exp**
                   (cons **env**
                         (cons **unevlis**
                               (cons **evlis**
                                     (cons retag **clink**)))))))

(defun restore ()
  (prog (ltem)
       (setq ltem (or **clink**
		     (error '|Process Ran Out - Restore|
			     **exp**
			     'fail-act))
             **exp** (car ltem)
              ltem (cdr ltem)
             **env** (car ltem)
              ltem (cdr ltem)
             **unevlis** (car ltem)
              ltem (cdr ltem)
             **evlis** (car ltem)
              ltem (cdr ltem)
             **pc** (car ltem)
             **clink** (cdr ltem))))